home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xlbfun.c < prev    next >
Text File  |  1985-12-25  |  14KB  |  648 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE ***xlstack,*xlenv;
  10. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
  11. extern NODE *s_lambda,*s_macro;
  12. extern NODE *s_comma,*s_comat;
  13. extern NODE *s_unbound;
  14. extern char gsprefix[];
  15. extern int gsnumber;
  16.  
  17. /* forward declarations */
  18. FORWARD NODE *bquote1();
  19. FORWARD NODE *defun();
  20. FORWARD NODE *makesymbol();
  21.  
  22. /* xeval - the built-in function 'eval' */
  23. NODE *xeval(args)
  24.   NODE *args;
  25. {
  26.     NODE ***oldstk,*expr,*val;
  27.  
  28.     /* create a new stack frame */
  29.     oldstk = xlsave(&expr,NULL);
  30.  
  31.     /* get the expression to evaluate */
  32.     expr = xlarg(&args);
  33.     xllastarg(args);
  34.  
  35.     /* evaluate the expression */
  36.     val = xleval(expr);
  37.  
  38.     /* restore the previous stack frame */
  39.     xlstack = oldstk;
  40.  
  41.     /* return the expression evaluated */
  42.     return (val);
  43. }
  44.  
  45. /* xapply - the built-in function 'apply' */
  46. NODE *xapply(args)
  47.   NODE *args;
  48. {
  49.     NODE ***oldstk,*fun,*arglist,*val;
  50.  
  51.     /* create a new stack frame */
  52.     oldstk = xlsave(&fun,&arglist,NULL);
  53.  
  54.     /* get the function and argument list */
  55.     fun = xlarg(&args);
  56.     arglist = xlmatch(LIST,&args);
  57.     xllastarg(args);
  58.  
  59.     /* if the function is a symbol, get its value */
  60.     if (symbolp(fun))
  61.     fun = xleval(fun);
  62.  
  63.     /* apply the function to the arguments */
  64.     val = xlapply(fun,arglist);
  65.  
  66.     /* restore the previous stack frame */
  67.     xlstack = oldstk;
  68.  
  69.     /* return the expression evaluated */
  70.     return (val);
  71. }
  72.  
  73. /* xfuncall - the built-in function 'funcall' */
  74. NODE *xfuncall(args)
  75.   NODE *args;
  76. {
  77.     NODE ***oldstk,*fun,*arglist,*val;
  78.  
  79.     /* create a new stack frame */
  80.     oldstk = xlsave(&fun,&arglist,NULL);
  81.  
  82.     /* get the function and argument list */
  83.     fun = xlarg(&args);
  84.     arglist = args;
  85.  
  86.     /* if the function is a symbol, get its value */
  87.     if (symbolp(fun))
  88.     fun = xleval(fun);
  89.  
  90.     /* apply the function to the arguments */
  91.     val = xlapply(fun,arglist);
  92.  
  93.     /* restore the previous stack frame */
  94.     xlstack = oldstk;
  95.  
  96.     /* return the expression evaluated */
  97.     return (val);
  98. }
  99.  
  100. /* xquote - built-in function to quote an expression */
  101. NODE *xquote(args)
  102.   NODE *args;
  103. {
  104.     NODE *val;
  105.  
  106.     /* get the argument */
  107.     val = xlarg(&args);
  108.     xllastarg(args);
  109.  
  110.     /* return the quoted expression */
  111.     return (val);
  112. }
  113.  
  114. /* xfunction - built-in function to quote a function */
  115. NODE *xfunction(args)
  116.   NODE *args;
  117. {
  118.     NODE *val;
  119.  
  120.     /* get the argument */
  121.     val = xlarg(&args);
  122.     xllastarg(args);
  123.  
  124.     /* create a closure for lambda expressions */
  125.     if (consp(val) && car(val) == s_lambda)
  126.     val = cons(val,xlenv);
  127.  
  128.     /* otherwise, get the value of a symbol */
  129.     else if (symbolp(val))
  130.     val = xlgetvalue(val);
  131.  
  132.     /* otherwise, its an error */
  133.     else
  134.     xlerror("not a function",val);
  135.  
  136.     /* return the function */
  137.     return (val);
  138. }
  139.  
  140. /* xlambda - lambda function */
  141. NODE *xlambda(args)
  142.   NODE *args;
  143. {
  144.     NODE ***oldstk,*fargs,*closure;
  145.  
  146.     /* create a new stack frame */
  147.     oldstk = xlsave(&fargs,&closure,NULL);
  148.  
  149.     /* get the formal argument list */
  150.     fargs = xlmatch(LIST,&args);
  151.  
  152.     /* create a new function definition */
  153.     closure = cons(fargs,args);
  154.     closure = cons(s_lambda,closure);
  155.     closure = cons(closure,xlenv);
  156.  
  157.     /* restore the previous stack frame */
  158.     xlstack = oldstk;
  159.  
  160.     /* return the closure */
  161.     return (closure);
  162. }
  163.  
  164. /* xbquote - back quote function */
  165. NODE *xbquote(args)
  166.   NODE *args;
  167. {
  168.     NODE ***oldstk,*expr,*val;
  169.  
  170.     /* create a new stack frame */
  171.     oldstk = xlsave(&expr,NULL);
  172.  
  173.     /* get the expression */
  174.     expr = xlarg(&args);
  175.     xllastarg(args);
  176.  
  177.     /* fill in the template */
  178.     val = bquote1(expr);
  179.  
  180.     /* restore the previous stack frame */
  181.     xlstack = oldstk;
  182.  
  183.     /* return the result */
  184.     return (val);
  185. }
  186.  
  187. /* bquote1 - back quote helper function */
  188. LOCAL NODE *bquote1(expr)
  189.   NODE *expr;
  190. {
  191.     NODE ***oldstk,*val,*list,*last,*new;
  192.  
  193.     /* handle atoms */
  194.     if (atom(expr))
  195.     val = expr;
  196.  
  197.     /* handle (comma <expr>) */
  198.     else if (car(expr) == s_comma) {
  199.     if (atom(cdr(expr)))
  200.         xlfail("bad comma expression");
  201.     val = xleval(car(cdr(expr)));
  202.     }
  203.  
  204.     /* handle ((comma-at <expr>) ... ) */
  205.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  206.     oldstk = xlsave(&list,&val,NULL);
  207.     if (atom(cdr(car(expr))))
  208.         xlfail("bad comma-at expression");
  209.     list = xleval(car(cdr(car(expr))));
  210.     for (last = NIL; consp(list); list = cdr(list)) {
  211.         new = consa(car(list));
  212.         if (last)
  213.         rplacd(last,new);
  214.         else
  215.         val = new;
  216.         last = new;
  217.     }
  218.     if (last)
  219.         rplacd(last,bquote1(cdr(expr)));
  220.     else
  221.         val = bquote1(cdr(expr));
  222.     xlstack = oldstk;
  223.     }
  224.  
  225.     /* handle any other list */
  226.     else {
  227.     oldstk = xlsave(&val,NULL);
  228.     val = consa(NIL);
  229.     rplaca(val,bquote1(car(expr)));
  230.     rplacd(val,bquote1(cdr(expr)));
  231.     xlstack = oldstk;
  232.     }
  233.  
  234.     /* return the result */
  235.     return (val);
  236. }
  237.  
  238. /* xset - built-in function set */
  239. NODE *xset(args)
  240.   NODE *args;
  241. {
  242.     NODE *sym,*val;
  243.  
  244.     /* get the symbol and new value */
  245.     sym = xlmatch(SYM,&args);
  246.     val = xlarg(&args);
  247.     xllastarg(args);
  248.  
  249.     /* assign the symbol the value of argument 2 and the return value */
  250.     setvalue(sym,val);
  251.  
  252.     /* return the result value */
  253.     return (val);
  254. }
  255.  
  256. /* xsetq - built-in function setq */
  257. NODE *xsetq(args)
  258.   NODE *args;
  259. {
  260.     NODE ***oldstk,*arg,*sym,*val;
  261.  
  262.     /* create a new stack frame */
  263.     oldstk = xlsave(&arg,&sym,&val,NULL);
  264.  
  265.     /* initialize */
  266.     arg = args;
  267.  
  268.     /* handle each pair of arguments */
  269.     while (arg) {
  270.     sym = xlmatch(SYM,&arg);
  271.     val = xlevarg(&arg);
  272.     xlsetvalue(sym,val);
  273.     }
  274.  
  275.     /* restore the previous stack frame */
  276.     xlstack = oldstk;
  277.  
  278.     /* return the result value */
  279.     return (val);
  280. }
  281.  
  282. /* xsetf - built-in function 'setf' */
  283. NODE *xsetf(args)
  284.   NODE *args;
  285. {
  286.     NODE ***oldstk,*arg,*place,*value;
  287.  
  288.     /* create a new stack frame */
  289.     oldstk = xlsave(&arg,&place,&value,NULL);
  290.  
  291.     /* initialize */
  292.     arg = args;
  293.  
  294.     /* handle each pair of arguments */
  295.     while (arg) {
  296.  
  297.     /* get place and value */
  298.     place = xlarg(&arg);
  299.     value = xlevarg(&arg);
  300.  
  301.     /* check the place form */
  302.     if (symbolp(place))
  303.         xlsetvalue(place,value);
  304.     else if (consp(place))
  305.         placeform(place,value);
  306.     else
  307.         xlfail("bad place form");
  308.     }
  309.  
  310.     /* restore the previous stack frame */
  311.     xlstack = oldstk;
  312.  
  313.     /* return the value */
  314.     return (value);
  315. }
  316.  
  317. /* placeform - handle a place form other than a symbol */
  318. LOCAL placeform(place,value)
  319.   NODE *place,*value;
  320. {
  321.     NODE ***oldstk,*fun,*arg1,*arg2;
  322.     int i;
  323.  
  324.     /* check the function name */
  325.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  326.     oldstk = xlsave(&arg1,&arg2,NULL);
  327.     arg1 = xlevmatch(SYM,&place);
  328.     arg2 = xlevmatch(SYM,&place);
  329.     xllastarg(place);
  330.     xlputprop(arg1,value,arg2);
  331.     xlstack = oldstk;
  332.     }
  333.     else if (fun == s_svalue || fun == s_splist) {
  334.     oldstk = xlsave(&arg1,NULL);
  335.     arg1 = xlevmatch(SYM,&place);
  336.     xllastarg(place);
  337.     if (fun == s_svalue)
  338.         setvalue(arg1,value);
  339.     else
  340.         setplist(arg1,value);
  341.     xlstack = oldstk;
  342.     }
  343.     else if (fun == s_car || fun == s_cdr) {
  344.     oldstk = xlsave(&arg1,NULL);
  345.     arg1 = xlevmatch(LIST,&place);
  346.     xllastarg(place);
  347.     if (consp(arg1))
  348.         if (fun == s_car)
  349.         rplaca(arg1,value);
  350.         else
  351.         rplacd(arg1,value);
  352.     xlstack = oldstk;
  353.     }
  354.     else if (fun == s_nth) {
  355.     oldstk = xlsave(&arg1,&arg2,NULL);
  356.     arg1 = xlevmatch(INT,&place);
  357.     arg2 = xlevmatch(LIST,&place);
  358.     xllastarg(place);
  359.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  360.         arg2 = cdr(arg2);
  361.     if (consp(arg2))
  362.         rplaca(arg2,value);
  363.     xlstack = oldstk;
  364.     }
  365.  
  366.     else if (fun == s_aref) {
  367.     oldstk = xlsave(&arg1,&arg2,NULL);
  368.     arg1 = xlevmatch(VECT,